Delphi Magazine Collection 2001

home *** CD-ROM | disk | FTP | other *** search

/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue54 / Persist / tiButtonPanel.pas < prev next >

Wrap

Pascal/Delphi Source File | 2000-01-07 | 82.8 KB | 2,824 lines

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * TechInsite Pty. Ltd. PO Box 429, Abbotsford, Melbourne. 3067 Australia Phone: +61 3 9419 6456 Fax: +61 3 9419 1682 Web: www.techinsite.com.au EMail: info@techinsite.com.au Notes: * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} unit tiButtonPanel; interface uses Windows, SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, mask, buttons, extCtrls, gauges, printers, fileCtrl, db, dbTables, grids, DBGrids, comctrls, spin, registry, ImgList ,math // min ; const cValidFloatChrs: set of char = [ '-', '.', '0', '1', '2', '3', '4', '5', '6', '7', '8', '9' ] ; type // A TCustomPanel with the border set to none, and the caption turned off. // This control is not registered with the component pallet, as it // is intended for use as the starting point for composite controls. //---------------------------------------------------------------------------- TtiPanel = class( TCustomPanel ) public Constructor Create( owner : TComponent ) ; override ; end ; // TtiStaticPickList: Lists with items hard-coded into the program //---------------------------------------------------------------------------- TtiStaticPickList = class( TCustomComboBox ) private procedure setText( sValue : string ) ; function getText : string ; protected procedure Loaded ; override ; procedure ReadItems ; virtual ; abstract ; published property Text : string read getText write setText ; property Top ; property Left ; property Height ; property Width ; property Visible ; property Enabled ; property OnExit ; property OnChange ; property ShowHint ; public constructor create( owner : TComponent ) ; override ; end; //---------------------------------------------------------------------------- RangeException = class( Exception ) ; TFloatValidateEvent = procedure( Sender: TWinControl ; var rValue : real) of object; TBaseFloatEdit = class( TCustomEdit ) private FsEditMask : string ; FbApplyMask : boolean ; FiPrecision : integer ; FOnValidate : TFloatValidateEvent ; FsTextBefore : string ; FsTextAfter : string ; FrMinValue : real ; FrMaxValue : real ; FsBeforeApplyKey : string ; function getAsString : string ; procedure setAsString( sValue: string); procedure setAsFloat( rValue : real ) ; function getAsFloat : real ; procedure BaseFloatEditClick( sender : TObject ) ; procedure enterBaseFloatEdit( sender : TObject ) ; procedure exitBaseFloatEdit( sender : TObject ) ; procedure baseFloatKeyPress( Sender: TObject; var Key: Char ); procedure baseFloatOnChange( sender : TObject ) ; function removeFormatChr( sValue : string ) : string ; procedure setPrecision( iValue : integer ) ; function isValidFloat( sValue : string ) : boolean ; procedure refresh ; procedure setTextAfter( sValue : string ) ; procedure setTextBefore( sValue : string ) ; procedure setMinValue( rValue : real ) ; procedure setMaxValue( rValue : real ) ; procedure setApplyMask( bValue : boolean ) ; function withinMinMaxLimits( value : real ) : boolean; function customStrToFloat(var pStrValue: string): real; protected property TextBefore : string read FsTextBefore write setTextBefore ; property TextAfter : string read FsTextAfter write setTextAfter ; property AsString : string read getAsString write setAsString ; property AsFloat : real read getAsFloat write setAsFloat ; property Precision : integer read FiPrecision write setPrecision ; property MinValue : real read FrMinValue write setMinValue ; property MaxValue : real read FrMaxValue write setMaxValue ; published // property OnChange ; property OnValidate : TFloatValidateEvent read FOnValidate write FOnValidate ; // Don't publish this, as it is used internally. Use OnValidate instead. // property OnExit ; property Font ; property TabOrder ; property ApplyMask : boolean read FbApplyMask write setApplyMask ; // property MaxLength ; public constructor create( owner : TComponent ) ; override ; end ; // TtiDBGrid //------------------------------------------------------------------------------ TTextOrBitmap = ( tobTextOnly, tobBitmapOnly, tobBoth ) ; TCalcCellDispPropsEvent = procedure( Sender: TObject ; dataSet : TDataSet ; sFieldName : string ; var colorFont, colorCell : TColor ) of object; TCalcCellBitMapEvent = procedure( Sender: TObject ; dataSet : TDataSet ; sFieldName : string ; bitMap : TBitMap ; var textOrBitmap : TTextOrBitmap ) of object; TtiDBGrid = class( TCustomDBGrid ) private FBitmap : TBitmap ; FOnCalcCellDispProps : TCalcCellDispPropsEvent ; FOnCalcCellBitMap : TCalcCellBitMapEvent ; procedure customDrawCell(Sender: TObject; const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState); virtual ; procedure drawBitmapInCell(const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState ; textOrBitmap : TTextOrBitmap ); protected published property Align; property Anchors; property BorderStyle; property Ctl3D; property Color; property Columns stored False; //StoreColumns; property Constraints; property DataSource; property Enabled; property FixedColor; property Font; property Options; property PopupMenu; property ReadOnly; property ShowHint; property SelectedRows ; property TabOrder; property TabStop; property TitleFont; property Visible; property OnDblClick; property OnKeyPress; property OnTitleClick; property OnCalcCellDispProps : TCalcCellDispPropsEvent read FOnCalcCellDispProps write FOnCalcCellDispProps ; property OnCalcCellBitmap : TCalcCellBitMapEvent read FOnCalcCellBitMap write FOnCalcCellBitMap ; property OnEnter ; property OnExit ; // property BiDiMode; // property DefaultDrawing; // property DragCursor; // property DragKind; // property DragMode; // property ImeMode; // property ImeName; // property ParentBiDiMode; // property ParentColor; // property ParentCtl3D; // property ParentFont; // property ParentShowHint; // property OnCellClick; // property OnColEnter; // property OnColExit; // property OnColumnMoved; // property OnDrawColumnCell; // property OnDrawDataCell; // obsolete // property OnDragDrop; // property OnDragOver; // property OnEditButtonClick; // property OnEndDock; // property OnEndDrag; // property OnEnter; // property OnExit; // property OnKeyDown; // property OnKeyUp; // property OnStartDock; // property OnStartDrag; public constructor create( owner : TComponent ) ; override ; destructor destroy ; override ; property canvas ; end ; // TPickList: Dynamic pick lists. Lists with items looked up at runtime TPickList = class( TCustomPanel ) //------------------------------------------------------------------------------ TtiPickList = class( TCustomPanel ) private oEdit : TEdit ; oSpeedButton : TSpeedButton ; oTable : TTable ; oDataSource : TDataSource ; oForm : TForm ; oDBGrid : TDBGrid ; FsGridFieldNames : string ; FsGridDisplayLables : string ; FsEditFieldNames : string ; FsReturnFieldName : string ; FsRange : string ; FsSearchText : string ; FOnChange : TNotifyEvent ; procedure WMSize( var Message: TWMSize ) ; message WM_SIZE ; procedure speedButtonClick( sender : TObject ) ; procedure oFormDeactivate( Sender: TObject ) ; procedure DBGridKeyPress( Sender: TObject ; var Key : Char ); procedure DBGridDblClick( Sender: TObject ) ; procedure EditKeyPress( Sender: TObject ; var Key : Char ); procedure EditKeyDown( Sender: TObject ; var Key : word ;Shift: TShiftState ); procedure copyTextToEdit ; procedure openTable ; procedure setTableName( sValue : string ) ; function getTableName : string ; procedure setIndexName( sValue : string ) ; function getIndexName : string ; function getText : string ; procedure setText( sValue : string ) ; procedure setSearchText( sValue : string ) ; property searchText : string read FsSearchText write setSearchText ; procedure setRange( sValue : string ) ; protected property tableName : string read getTableName write setTableName ; property indexName : string read getIndexName write setIndexName ; property gridFieldNames : string read FsGridFieldNames write FsGridFieldNames ; property gridDisplayLables : string read FsGridDisplayLables write FsGridDisplayLables ; property editFieldNames : string read FsEditFieldNames write FsEditFieldNames ; property ReturnField : string read FsReturnFieldName write FsReturnFieldName ; property range : string read FsRange write setRange ; public published constructor create( oOwner : TComponent ) ; override ; destructor free ; property Top ; property Left ; property Width ; property Height ; property visible ; property enabled ; property OnExit ; property OnChange: TNotifyEvent read FOnChange write FOnChange; property text : string read getText write setText ; end; // TAbort: Abort dialog box. //---------------------------------------------------------------------------- TtiAbort = class(TComponent) private oForm : TForm ; oGauge : TGauge ; oBitBtnAbort : TBitBtn ; bAbort : boolean ; procedure bitBtnAbortClick( sender : TObject ) ; procedure pPutMaxValue( iMaxValue : longInt ) ; function pGetMaxValue : longInt ; procedure pPutProgress( iProgress : longInt ) ; function pGetProgress : longInt ; published constructor create( oOwner : TComponent ) ; override ; destructor destroy ; override ; property abort : boolean read bAbort write bAbort ; property maxValue : longInt read pGetMaxValue write pPutMaxValue ; property progress : longInt read pGetProgress write pPutProgress ; function IncGauge : boolean ; function Inc : boolean ; procedure show( sCaption : string ; iMaxValue : longInt ) ; procedure hide ; end; // TPickPrinter //------------------------------------------------------------------------------ TtiPickPrinter = class( TtiStaticPickList ) public procedure readItems ; override ; end ; // TCustomPicker //------------------------------------------------------------------------------ TtiCustomPicker = class( TCustomPanel ) private oEdit : TEdit ; oSpeedButton : TSpeedButton ; FOnChange : TNotifyEvent ; procedure WMSize( var Message: TWMSize ) ; message WM_SIZE ; procedure buttonClick( sender : TObject ) ; virtual ; procedure setText( sValue : string ) ; virtual ; function getText : string ; virtual ; procedure editChange( sender : TObject ) ; protected property onClick ; public constructor create( owner : TComponent ) ; override ; published property Anchors ; property text : string read getText write setText ; property font ; //property onExit ; property onChange : TNotifyEvent read FOnChange write FOnChange ; end ; // TPickDirectory //------------------------------------------------------------------------------ TtiPickDirectory = class( TtiCustomPicker ) private FbMustExist : boolean ; FbCreateDir: boolean; procedure buttonClick( sender : TObject ) ; override ; procedure pickDirectoryOnExit( sender : TObject ) ; protected procedure loaded ; override ; published property MustExist : boolean read FbMustExist write FbMustExist ; property CreateDir : boolean read FbCreateDir write FbCreateDir default false ; public constructor create( owner : TComponent ) ; override ; end ; // TPickFile //------------------------------------------------------------------------------ TtiPickFile = class( TtiCustomPicker ) private FsDefaultExt : string ; FsFilter : string ; FsTitle : string ; procedure buttonClick( sender : TObject ) ; override ; published property onExit ; property DefaultExt : string read FsDefaultExt write FsDefaultExt ; property Filter : string read FsFilter write FsFilter ; property Title : string read FsTitle write FsTitle ; property Visible ; public constructor create( owner : TComponent); override ; end ; // TAmuseUser //------------------------------------------------------------------------------ TtiAmuseUser = class(TComponent) private oForm : TForm ; oGauge : TGauge ; oLabel : TLabel ; oTimer : TTimer ; function getCaption : string ; procedure setCaption( sValue : string ) ; function getMessageLine : string ; procedure setMessageLine( sValue : string ) ; procedure oTimerTimer( sender: TObject ) ; procedure setEnabled( bValue : boolean ) ; function getEnabled : boolean ; published constructor create( oOwner : TComponent ) ; override ; destructor free ; property enabled : boolean read getEnabled write setEnabled ; property caption : string read getCaption write setCaption ; property messageLine : string read getMessageLine write setMessageLine ; end ; // THistoryComboBox //------------------------------------------------------------------------------ TtiHistoryComboBox = class(TCustomComboBox) private FOnValidate : TNotifyEvent ; FiHistoryCount: integer; oReg : TRegINIFile ; procedure historyComboBoxExit(sender: TObject); procedure SetHistoryCount(const iValue: integer); protected procedure loaded ; override ; published property Anchors ; property Color ; property Font ; property Enabled ; property ShowHint ; property MaxLength ; property Text ; property TabOrder ; property HistoryCount : integer read FiHistoryCount write setHistoryCount ; property onValidate : TNotifyEvent read FOnValidate write FOnValidate ; property onChange ; public constructor create(owner: TComponent);override; destructor destroy ; override ; end ; //---------------------------------------------------------------------------- TtiFloatEdit = class( TBaseFloatEdit ) private protected published property AsString ; property AsFloat ; property Precision ; property MinValue ; property MaxValue ; public constructor create( owner : TComponent ) ; override ; end ; //---------------------------------------------------------------------------- TtiCurrencyEdit = class( TBaseFloatEdit ) private protected published property AsString ; property AsFloat ; property Precision ; property MinValue ; property MaxValue ; public constructor create( owner : TComponent ) ; override ; end ; //---------------------------------------------------------------------------- TtiPercentEdit = class( TBaseFloatEdit ) private protected published property AsString ; property AsFloat ; property Precision ; property MinValue ; property MaxValue ; public constructor create( owner : TComponent ) ; override ; end ; //---------------------------------------------------------------------------- TtiIntegerEdit = class( TBaseFloatEdit ) private function getAsInteger : longInt ; procedure setAsInteger( iValue : longInt ) ; protected published property AsString ; property AsInteger : longInt read getAsInteger write setAsInteger ; property MinValue ; property MaxValue ; public constructor create( owner : TComponent ) ; override ; end ; //---------------------------------------------------------------------------- TtiDateEdit = class( TDateTimePicker ) private FsDate : string ; protected published property DateAsString : string read FsDate ; public end ; //---------------------------------------------------------------------------- TtiToolBar = class( TToolBar ) private protected published public constructor create( owner : TComponent ) ; override ; end ; // TtiPickAlias //---------------------------------------------------------------------------- TtiPickAlias = class( TtiStaticPickList ) private protected procedure ReadItems ; override ; published public end; // TDateRange //---------------------------------------------------------------------------- TDateGroup = ( dgAll, dgWeek, dgMonth, dgToday, dgCustom ) ; TtiDateRange = class( TCustomGroupBox ) private labelFrom : TLabel ; labelTo : TLabel ; FDateTimePickerFrom : TDateTimePicker ; FDateTimePickerTo : TDateTimePicker ; radioButtonDatesAll : TRadioButton ; radioButtonDatesMonth : TRadioButton ; radioButtonDatesWeek : TRadioButton ; radioButtonDatesToday : TRadioButton ; radioButtonDatesCustom : TRadioButton ; dDateAllEarliest : TDateTime ; dDateAllLatest : TDateTime ; FDateGroup : TDateGroup ; FOnChange : TNotifyEvent ; procedure RadioButtonDatesClick( sender: TObject) ; function getDateFrom : TDateTime ; procedure putDateFrom( const dDate : TDateTime ) ; function getDateTo : TDateTime ; procedure putDateTo( const dDate : TDateTime ) ; procedure setDateGroup( const dgDateGroup : TDateGroup ) ; function getDateGroup : TDateGroup ; procedure OnChangeEvent( sender : TObject ) ; protected procedure Loaded; override ; published constructor create( oOwner : TComponent ) ; override ; property dateAllEarliest : TDateTime read dDateAllEarliest write dDateAllEarliest ; property dateAllLatest : TDateTime read dDateAllLatest write dDateAllLatest ; property dateFrom : TDateTime read getDateFrom write putDateFrom ; property dateTo : TDateTime read getDateTo write putDateTo ; property dateGroup : TDateGroup read getDateGroup write setDateGroup default dgCustom ; property top ; property left ; property OnChange : TNotifyEvent read FOnChange write FOnChange ; end; // TOnDirectoryEvent = procedure( Sender: TWinControl ; // var pDirectory : string ) of object; TtiClock = class( TtiPanel ) private FTimer : TTimer ; FLabel : TLabel ; FsTimeFormat: string; FiOffset : integer ; procedure SetTimeFormat(const Value: string); protected procedure OnTimer( sender : TObject ) ; virtual ; function GetEnabled: boolean; override ; procedure SetEnabled( Value: boolean); override ; published property Enabled : boolean read GetEnabled write SetEnabled ; property TimeFormat : string read FsTimeFormat write SetTimeFormat ; property Offset : integer read FiOffset write FiOffset ; property Font ; property Color ; public Constructor Create( owner : TComponent ) ; override ; end ; TtiButtonPanel = class( TCustomPanel ) private FOnBtn2Click: TNotifyEvent; FOnBtn1Click: TNotifyEvent; FBtn1 : TBitBtn ; FBtn2 : TBitBtn ; procedure SetOnBtn1Click(const Value: TNotifyEvent); procedure SetOnBtn2Click(const Value: TNotifyEvent); protected procedure DoBtn1Click( sender : TObject ) ; virtual ; procedure DoBtn2Click( sender : TObject ) ; virtual ; published property OnBtn1Click : TNotifyEvent read FOnBtn1Click write SetOnBtn1Click ; property OnBtn2Click : TNotifyEvent read FOnBtn2Click write SetOnBtn2Click ; public Constructor Create( owner : TComponent ) ; override ; Destructor Destroy ; override ; end ; TtiMessageDlg = class( TComponent ) private FForm : TForm ; FBtns : TList ; FMemo : TMemo ; FsResult : string ; Procedure Clear ; Procedure DoOnClick( sender : TObject ) ; public Constructor Create( owner : TComponent ) ; override ; Destructor Destroy ; override ; Function Execute( const psMessage : string ; paOptions : array of string ; psCaption : string ) : string ; end ; const clPaleYellow = $00E8FFFE ; clPaleBlue = $00FFF1EA ; clPaleNavy = $00FFEAED ; clPaleGreen = $00B3FFB3 ; clPalePink = $008080FF ; cDefaultDateString = '01/01/1980' ; cMinHeight = 21 ; cMinWidth = 121 ; cTimeFormat = 'hh:mm:ss am/pm' ; cFloatEditMask = '#,##0' ; cMyComputer = 'My computer' ; csSubDirPlaceHolder = 'SubDirPlaceHolder' ; cuStrDirectoryDelimiter = '\' ; function tiNumToken( sString, sToken : string ) : integer ; function tiToken( sString, sToken : string; iNum : integer ) : string ; function tiStrTran( sStr, sDel, sIns : string ) : string ; function tiRemoveExtension( sValue : string ) : string ; implementation const cdtOneSecond = 1/24/60/60 ; //* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * //* //* TtiStaticPickList //* //* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} //------------------------------------------------------------------------------ constructor TtiStaticPickList.create( owner : TComponent ) ; begin inherited create( owner ) ; self.style := csDropDownList ; end ; //------------------------------------------------------------------------------ function TtiStaticPickList.getText : string ; begin // readItems ; if self.itemIndex = - 1 then begin result := '' ; end else begin result := self.items[ self.itemIndex ] ; end ; end ; //------------------------------------------------------------------------------ procedure TtiStaticPickList.setText( sValue : string ) ; begin // readItems ; self.itemIndex := self.items.indexOf( sValue ) ; end ; //------------------------------------------------------------------------------ procedure TtiStaticPickList.Loaded ; begin inherited ; ReadItems ; //if self.items.count > 0 then begin // exit ; //end ; end ; { procedure TtiStaticPickList.readItems ; begin if self.items.count > 0 then begin exit ; end ; end ; } { //------------------------------------------------------------------------------ procedure TtiStaticPickList.dropDown ; begin self.readItems ; end ; } //* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * //* //* TBaseFloatEdit //* //* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * //------------------------------------------------------------------------------ constructor TBaseFloatEdit.create( owner : TComponent ) ; begin inherited create( owner ) ; onEnter := enterBaseFloatEdit ; onExit := exitBaseFloatEdit ; onKeyPress := baseFloatKeyPress ; onChange := baseFloatOnChange ; onClick := baseFloatEditClick ; self.width := 57 ; FsEditMask := cFloatEditMask ; FsTextBefore := '' ; FsTextAfter := '' ; FrMinValue := 0 ; FrMaxValue := 0 ; FbApplyMask := true ; FsBeforeApplyKey := '' ; self.precision := 0 ; self.asFloat := 0 ; end ; //------------------------------------------------------------------------------ procedure TBaseFloatEdit.setAsString( sValue : string ) ; begin if sValue = '' then begin self.asFloat := 0 ; exit ; end ; if not isValidFloat( sValue ) then begin self.asFloat := 0 ; exit ; end ; self.text := sValue ; self.refresh ; end ; //------------------------------------------------------------------------------ function TBaseFloatEdit.getAsString : string ; begin result := self.text ; end ; //------------------------------------------------------------------------------ function TBaseFloatEdit.isValidFloat( sValue : string ) : boolean ; var rValue : real ; begin try rValue := strToFloat( self.removeFormatChr( sValue )) ; if rValue < rValue + 1 then ; // To trick compiler warnings result := true ; except result := false ; end ; end ; //------------------------------------------------------------------------------ function TBaseFloatEdit.getAsFloat : real ; var lStr : string ; begin lStr := self.text ; result := self.customStrToFloat( lStr ) ; end ; //------------------------------------------------------------------------------ function TBaseFloatEdit.customStrToFloat( var pStrValue : string ) : real ; var lStrValue : string ; begin lStrValue := self.removeFormatChr( pStrValue ) ; if lStrValue = '' then begin result := 0 ; exit ; //==> end ; try result := strToFloat( lStrValue ) ; except result := 0 ; end ; end ; //------------------------------------------------------------------------------ procedure TBaseFloatEdit.setAsFloat( rValue : real ) ; var sValue : string ; sMinValue : string ; sMaxValue : string ; begin // try sValue := FsTextBefore + formatFloat( FsEditMask, rValue ) + FsTextAfter ; if not self.withinMinMaxLimits( rValue ) then begin { if (( FrMinValue <> 0 ) and ( rValue < FrMinValue )) or (( FrMaxValue <> 0 ) and ( rValue > FrMaxValue )) then begin // What if one of our FsM??Values are 0 ? // Require some code to handle these situations } sMinValue := FsTextBefore + formatFloat( FsEditMask, FrMinValue ) + FsTextAfter ; sMaxValue := FsTextBefore + formatFloat( FsEditMask, FrMaxValue ) + FsTextAfter ; raise RangeException.create( 'The value you entered, ' + sValue + ' is out of range.' + #13 + 'Please enter a value between ' + sMinValue + ' and ' + sMaxValue ) ; end ; self.text := sValue ; // except // self.asFloat := 0 ; // end ; end ; //------------------------------------------------------------------------------ function TBaseFloatEdit.withinMinMaxLimits( value : real ) : boolean ; begin result := not ((( FrMinValue <> 0 ) and ( value < FrMinValue )) or (( FrMaxValue <> 0 ) and ( value > FrMaxValue ))) ; // What if one of our FsM??Values are 0 ? // Require some code to handle these situations end ; //------------------------------------------------------------------------------ procedure TBaseFloatEdit.setMinValue( rValue : real ) ; begin if (FrMaxValue <> 0 ) and (rValue >= FrMaxValue) then rValue := 0 ; FrMinValue := rValue ; self.refresh ; end ; //------------------------------------------------------------------------------ procedure TBaseFloatEdit.setMaxValue( rValue : real ) ; begin if (FrMinValue <> 0) and (rValue <= FrMinValue) then rValue := 0 ; FrMaxValue := rValue ; self.refresh ; end ; //------------------------------------------------------------------------------ procedure TBaseFloatEdit.enterBaseFloatEdit( sender : TObject ) ; begin self.text := self.removeFormatChr( self.text ) ; self.selectAll ; end ; //------------------------------------------------------------------------------ procedure TBaseFloatEdit.exitBaseFloatEdit( sender : TObject ) ; var rValue : real ; begin try self.refresh ; except on e : rangeException do begin messageDlg( e.message, mtError, [mbOK], 0 ) ; self.setFocus ; end else begin self.setFocus ; raise ; end ; end ; rValue := self.AsFloat ; if assigned( onValidate ) then onValidate( self, rValue ) ; if rValue <> self.asFloat then self.asFloat := rValue ; end ; //------------------------------------------------------------------------------ function TBaseFloatEdit.removeFormatChr( sValue : string ) : string ; var i : integer ; begin result := '' ; for i := 1 to length( sValue ) do begin if sValue[i] in cValidFloatChrs then begin result := result + sValue[i] ; end ; end ; end ; //------------------------------------------------------------------------------ procedure TBaseFloatEdit.setPrecision( iValue : integer ) ; var i : integer ; begin FiPrecision := iValue ; FsEditMask := cFloatEditMask ; if FiPrecision > 0 then begin FsEditMask := FsEditMask + '.' ; for i := 1 to FiPrecision do begin FsEditMask := FsEditMask + '0' ; end ; end ; self.refresh ; end ; //------------------------------------------------------------------------------ procedure TBaseFloatEdit.refresh ; begin self.asFloat := self.asFloat ; end ; //------------------------------------------------------------------------------ procedure TBaseFloatEdit.baseFloatKeyPress(Sender: TObject;var Key: Char); begin FsBeforeApplyKey := self.text ; // A non character key? if ( ord( key ) < 32 ) or ( ord( key ) > 132 ) then begin exit ; end ; // A numeric key? if not ( key in cValidFloatChrs ) then begin key := char( 0 ) ; end ; end ; //------------------------------------------------------------------------------ procedure TBaseFloatEdit.baseFloatOnChange( sender : TObject ) ; var lReal : real ; lIntPos : integer ; begin lReal := self.AsFloat ; if not self.withinMinMaxLimits( lReal ) then begin lIntPos := self.selStart ; self.text := FsBeforeApplyKey ; self.selStart := lIntPos ; messageBeep( 0 ) ; end ; end ; //------------------------------------------------------------------------------ procedure TBaseFloatEdit.setTextAfter( sValue : string ) ; begin FsTextAfter := sValue ; self.refresh ; end ; //------------------------------------------------------------------------------ procedure TBaseFloatEdit.setTextBefore( sValue : string ) ; begin FsTextBefore := sValue ; self.refresh ; end ; //------------------------------------------------------------------------------ procedure TBaseFloatEdit.setApplyMask( bValue : boolean ) ; begin FbApplyMask := bValue ; if FbApplyMask then begin FsEditMask := cFloatEditMask ; end else begin FsEditMask := '###0' ; end ; self.refresh ; end ; //* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * //* //* TtiDBGrid //* //* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} constructor TtiDBGrid.create( owner : TComponent ) ; begin inherited ; onDrawColumnCell := customDrawCell ; defaultDrawing := false ; FBitmap := TBitmap.create ; end ; //------------------------------------------------------------------------------ destructor TtiDBGrid.destroy ; begin FBitmap.free ; inherited ; end ; //------------------------------------------------------------------------------ procedure TtiDBGrid.customDrawCell(Sender: TObject; const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState); var fontColor : TColor ; cellColor : TColor ; TextOrBitmap : TTextOrBitmap ; begin if assigned( FOnCalcCellDispProps ) then begin cellColor := canvas.brush.color ; fontColor := canvas.font.color ; FOnCalcCellDispProps( sender, TTIDBGrid(column.grid).dataSource.dataSet, upperCase( column.fieldName ), fontColor, cellColor ) ; if state = [] then begin canvas.brush.color := cellColor ; canvas.font.color := fontColor ; end else begin canvas.brush.color := clHighLight ; canvas.font.color := clHighLightText ; end ; end ; if assigned( FOnCalcCellBitMap ) then begin textOrBitmap := tobTextOnly ; FOnCalcCellBitMap( sender, TTIDBGrid(column.grid).dataSource.dataSet, upperCase( column.fieldName ), FBitmap, TextOrBitmap ) ; self.drawBitmapInCell( Rect, DataCol, Column, State, textOrBitmap ); end else begin self.DefaultDrawColumnCell( Rect, DataCol, Column, State ); end ; end ; //------------------------------------------------------------------------------ procedure TtiDBGrid.drawBitmapInCell(const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState ; textOrBitmap : TTextOrBitmap ); var newRect : TRect ; iTop : integer ; begin if textOrBitmap = tobTextOnly then begin self.DefaultDrawColumnCell( Rect, DataCol, Column, State ) ; exit ; // ==> end ; // Set so user can not edit a col with a bitmap, but causing probs saving // data to the underlying table. // column.readOnly := true ; if textOrBitmap = tobBitMapOnly then begin canvas.draw( rect.left+1, rect.top+1, FBitmap ) ; exit ; // ==> end ; if textOrBitmap = tobBoth then begin iTop := rect.bottom-FBitmap.height-1 ; FBitmap.transparentColor := canvas.brush.color ; canvas.draw( rect.left+1, iTop, FBitmap ) ; setRect( newRect, rect.left+2+FBitmap.width, rect.top, rect.right, rect.bottom ) ; self.DefaultDrawColumnCell( newRect, DataCol, Column, State ) ; exit ; // ==> end ; raise exception.create( 'Invalid textOrBitmap passed to TtiDBGrid.drawBitmapInCell' ) ; end ; //* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * //* //* Dynamic Pick Lists //* //* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} //------------------------------------------------------------------------------ constructor TtiPickList.create( oOwner : TComponent ) ; begin inherited create( oOwner ) ; with self do begin width := 217 ; height := 23 ; caption := ' ' ; bevelInner := bvNone ; bevelOuter := bvNone ; borderStyle := bsNone ; end ; oEdit := TEdit.create( self ) ; with oEdit do begin left := 1 ; top := 1 ; height := self.height-2; width := self.width - 3 - 17 ; parent := self ; borderStyle := bsSingle ; ctl3D := true ; onClick := speedButtonClick ; onKeyPress := editKeyPress ; onKeyDown := editKeyDown ; end ; oSpeedButton := TSpeedButton.create( self ) ; with oSpeedButton do begin left := self.width - 17 ; top := 1 ; width := 17 ; height := self.Height-2 ; parent := self ; try glyph.loadFromFile( 'tri_down.bmp' ) ; except caption := 'v' ; end ; onClick := speedButtonClick ; end ; oTable := TTable.create( self ) ; with oTable do begin showMessage( 'Requires work !' ) ; // dataBaseName := cDatabaseMain ; tableType := ttParadox ; end ; self.searchText := '' ; oDataSource := TDataSource.create( self ) ; oDataSource.dataSet := oTable ; oForm := TForm.create( self ) ; with oForm do begin borderStyle := bsNone ; height := 200 ; onDeactivate := oFormDeactivate ; end ; oDBGrid := TDBGrid.create( self ) ; with oDBGrid do begin dataSource := oDataSource ; parent := oForm ; align := alClient ; options := [dgTitles,dgColLines,dgRowLines,dgAlwaysShowSelection, dgRowSelect] ; onKeyPress := DBGridKeyPress ; onDblClick := DBGridDblClick ; end ; end ; //------------------------------------------------------------------------------ destructor TtiPickList.free ; begin oEdit.free ; oSpeedButton.free ; oTable.free ; oDataSource.free ; oForm.free ; oDBGrid.free ; end ; //------------------------------------------------------------------------------ procedure TtiPickList.setTableName( sValue : string ) ; begin oTable.close ; oTable.tableName := sValue ; openTable ; end ; //------------------------------------------------------------------------------ function TtiPickList.getTableName : string ; begin result := oTable.tableName ; end ; //------------------------------------------------------------------------------ procedure TtiPickList.setIndexName( sValue : string ) ; begin oTable.indexName := sValue ; end ; //------------------------------------------------------------------------------ function TtiPickList.getIndexName : string ; begin result := oTable.indexName ; end ; //------------------------------------------------------------------------------ function TtiPickList.getText : string ; begin if oEdit.text = '' then begin result := '' ; exit ; //==> end ; try result := oTable.fieldByName( self.returnField ).asString ; except result := '' ; end ; end ; //------------------------------------------------------------------------------ procedure TtiPickList.setSearchText( sValue : string ) ; begin FsSearchText := upperCase( sValue ) ; end ; //------------------------------------------------------------------------------ procedure TtiPickList.setRange( sValue : string ) ; begin FsRange := sValue ; try oTable.setRange([sValue], [sValue]) ; except // on e:exception do uAppException( 'Unable to set range to ' + // oTable.tablename + // ' <' + sValue + '>', e ) ; end ; end ; //------------------------------------------------------------------------------ procedure TtiPickList.setText( sValue : string ) ; begin try self.openTable ; self.searchText := sValue ; if self.searchText = '' then begin oEdit.text := '' ; exit ; //==> end ; if self.range <> '' then begin oTable.findNearest( [ self.range, self.searchText ] ) ; end else begin oTable.findNearest( [ self.searchText ] ) ; end ; self.copyTextToEdit ; except self.searchText := '' ; oEdit.text := '' ; end ; end ; //------------------------------------------------------------------------------ procedure TtiPickList.speedButtonClick( sender : TObject ) ; var pointTemp : TPoint ; begin pointTemp := clientToScreen( point( oEdit.left, oEdit.top + oEdit.height )) ; oForm.top := pointTemp.Y ; oForm.left := pointTemp.X ; oForm.font.assign( self.font ) ; self.openTable ; oForm.show ; end ; //------------------------------------------------------------------------------ procedure TtiPickList.openTable ; var i : integer ; sFieldName : string ; begin if oTable.state <> dsInactive then begin exit ; end ; if gridFieldNames = '' then begin exit ; // ==> end ; try with oTable do begin open ; if self.range <> '' then begin oTable.setRange([self.range], [self.range]) ; end ; for i := 0 to fieldCount - 1 do begin fields[i].visible := false ; end ; for i := 1 to tiNumToken( self.gridFieldNames, ';' ) do begin sFieldName := tiToken( self.gridFieldNames, ';', i ) ; fieldByName( sFieldName ).visible := true ; fieldByName( sFieldName ).displayLabel := tiToken( self.gridDisplayLables, ';', i ) ; end ; end ; oForm.width := self.width ; except end ; end ; //------------------------------------------------------------------------------ procedure TtiPickList.oFormDeactivate(Sender: TObject); begin oForm.hide ; oEdit.setFocus ; oEdit.selLength := 0 ; end; //------------------------------------------------------------------------------ procedure TtiPickList.DBGridKeyPress( Sender: TObject; var Key: Char ); begin self.openTable ; // Back space key if key = chr( 8 ) then begin self.searchText := '' ; try oTable.first ; except end ; oEdit.text := '' ; exit ; end ; // Return key if key = chr( 13 ) then begin DBGridDblClick( sender ) ; exit ; end ; self.searchText := self.searchText + upperCase( key ) ; try if self.range <> '' then begin oTable.findNearest( [ self.range, self.searchText ] ) ; end else begin oTable.findNearest( [ self.searchText ] ) ; end ; except end ; self.copyTextToEdit ; end; //------------------------------------------------------------------------------ procedure TtiPickList.DBGridDblClick(Sender: TObject); begin self.copyTextToEdit ; oFormDeactivate( sender ) ; if assigned( FOnChange ) then begin FOnChange( self ) ; end ; end; //------------------------------------------------------------------------------ procedure TtiPickList.EditKeyPress( Sender: TObject; var Key: Char ); begin case ord( key ) of 13 : speedButtonClick( sender ) ; 8 : begin oEdit.text := '' ; self.searchText := '' ; end else DBGridKeyPress( sender, key ) ; self.copyTextToEdit ; end ; key := #0 ; end; //------------------------------------------------------------------------------ procedure TtiPickList.EditKeyDown( Sender: TObject; var Key: word ; Shift: TShiftState ); begin if key = VK_DOWN then begin speedButtonClick( sender ) ; end ; end; //------------------------------------------------------------------------------ procedure TtiPickList.CopyTextToEdit ; var i : integer ; sText : string ; sFieldName : string ; begin if self.editFieldNames = '' then begin oEdit.text := '' ; exit ; // ==> end ; try sText := '' ; for i := 1 to tiNumToken( self.editFieldNames, ';' ) do begin sFieldName := tiToken( self.editFieldNames, ';', i ) ; if i <> 1 then begin sText := sText + ' - ' ; end ; sText := sText + oTable.fieldByName( sFieldName ).asString ; end ; oEdit.text := sText ; except oEdit.text := '' ; end ; end ; //------------------------------------------------------------------------------ procedure TtiPickList.WMSize( var Message : TWMSize ); begin inherited; if self.height < cMinHeight then begin self.height := cMinHeight ; end ; if self.width < cMinWidth then begin self.width := cMinWidth ; end ; oEdit.height := self.height -2; oEdit.width := self.width - 3 - 17 ; oSpeedButton.left := self.width - 17 ; oSpeedButton.height := self.Height -2 ; end; // * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * //* //* TAbort //* //* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} //------------------------------------------------------------------------------ constructor TtiAbort.create( oOwner : TComponent ) ; begin inherited create( oOwner ) ; oForm := TForm.create( self ) ; oBitBtnAbort := TBitBtn.create( self ) ; oGauge := TGauge.create( self ) ; self.abort := false ; with oForm do begin borderStyle := bsDialog ; borderIcons := [] ; caption := 'Abort dialogue' ; font.name := 'Arial' ; font.size := 9 ; font.color := clNavy ; height := 130 ; width := 300 ; position := poScreenCenter ; formStyle := fsStayOnTop ; with oGauge do begin parent := oForm ; top := 20 ; left := 10 ; width := 280 ; height := 20 ; maxValue := 100 ; color := clNavy ; foreColor:= clNavy ; showText := false ; end ; with oBitBtnAbort do begin parent := oForm ; top := 60 ; left := 110 ; width := 80 ; height := 25 ; kind := bkAbort ; onClick := bitBtnAbortClick ; end ; end ; application.processMessages ; end ; //------------------------------------------------------------------------------ destructor TtiAbort.destroy ; begin oForm.close ; oBitBtnAbort.free ; oGauge.free ; oForm.free ; inherited destroy ; end ; //------------------------------------------------------------------------------ procedure TtiAbort.bitBtnAbortClick( sender : TObject ) ; begin oForm.formStyle := fsNormal ; if messageDlg( 'Are you sure you want to abort this process ?', mtConfirmation, [mbNo, mbYes], 0 ) = mrYes then begin ; oForm.hide ; self.abort := true ; end ; end ; //------------------------------------------------------------------------------ procedure TtiAbort.pPutProgress( iProgress : longInt ) ; begin oGauge.progress := iProgress ; end ; //------------------------------------------------------------------------------ function TtiAbort.pGetProgress : longInt ; begin result := oGauge.progress ; end ; //------------------------------------------------------------------------------ procedure TtiAbort.pPutMaxValue( iMaxValue : longInt ) ; begin oGauge.maxValue := iMaxValue ; end ; //------------------------------------------------------------------------------ function TtiAbort.pGetMaxValue : longInt ; begin result := oGauge.maxValue ; end ; //------------------------------------------------------------------------------ function TtiAbort.incGauge : boolean ; begin oGauge.progress := oGauge.progress + 1 ; if oGauge.progress >= oGauge.maxValue then oGauge.progress := 0 ; application.processMessages ; result := not( self.abort ) ; end ; //------------------------------------------------------------------------------ function TtiAbort.Inc : boolean ; begin result := IncGauge ; end ; //------------------------------------------------------------------------------ procedure TtiAbort.hide ; begin oForm.hide ; end ; //------------------------------------------------------------------------------ procedure TtiAbort.show( sCaption : string ;iMaxValue : longInt ) ; begin oForm.caption := ' ' + sCaption ; self.maxValue := iMaxValue ; self.progress := 0 ; oForm.show ; application.processMessages ; end ; //* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * //* //* TCustomPicker //* //* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} //------------------------------------------------------------------------------ constructor TtiCustomPicker.create( Owner : TComponent ) ; begin inherited create( Owner ) ; ControlStyle := ControlStyle - [csSetCaption] ; with self do begin caption := ' ' ; BevelOuter := bvNone ; BorderWidth := 1 ; BorderStyle := bsSingle ; height := cMinHeight ; width := cMinWidth ; end ; oSpeedButton := TSpeedButton.create( self ) ; with oSpeedButton do begin top := 0 ; width := 16 ; parent := self ; glyph.handle := loadBitmap( HInstance, 'BMTHREEDOTS' ) ; numGlyphs := 1 ; onClick := buttonClick ; end ; oEdit := TEdit.create( self ) ; with oEdit do begin left := 0 ; top := 0 ; parent := self ; borderStyle := bsNone ; ctl3D := false ; onClick := buttonClick ; onChange := editChange ; end ; end ; //------------------------------------------------------------------------------ procedure TtiCustomPicker.buttonClick( sender : TObject ) ; begin // end; //------------------------------------------------------------------------------ procedure TtiCustomPicker.editChange(sender: TObject); begin if assigned( FOnChange ) then FOnChange( sender ) ; end; //------------------------------------------------------------------------------ procedure TtiCustomPicker.setText( sValue : string ) ; begin oEdit.text := sValue ; end ; //------------------------------------------------------------------------------ function TtiCustomPicker.getText : string ; begin result := oEdit.text ; end ; //------------------------------------------------------------------------------ procedure TtiCustomPicker.WMSize( var Message : TWMSize ); begin inherited; if self.height < cMinHeight then begin self.height := cMinHeight ; end ; if self.width < cMinWidth then begin self.width := cMinWidth ; end ; oSpeedButton.left := self.clientWidth - oSpeedButton.width ; oSpeedButton.height := self.clientHeight ; oEdit.height := self.clientHeight ; oEdit.width := self.clientWidth - oSpeedButton.width ; end; //* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * //* //* TPickPrinter //* //* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} //------------------------------------------------------------------------------ procedure TtiPickPrinter.readItems ; begin Items.Clear ; self.items.assign( printer.printers ) ; end ; //* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * //* //* TPickDirectory //* //* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} //------------------------------------------------------------------------------ constructor TtiPickDirectory.create( Owner : TComponent ) ; //var directoryBuffer : array[0..255] of char ; begin inherited create( Owner ) ; //getCurrentDirectory( 255, directoryBuffer ) ; // self.text := string( directoryBuffer ) ; FbCreateDir := false ; self.onExit := pickDirectoryOnExit ; end ; //------------------------------------------------------------------------------ procedure TtiPickDirectory.loaded ; var directoryBuffer : array[0..255] of char ; begin inherited loaded ; getCurrentDirectory( 255, directoryBuffer ) ; self.text := string( directoryBuffer ) ; end ; //------------------------------------------------------------------------------ procedure TtiPickDirectory.buttonClick( sender : TObject ) ; var formPickDir : TForm ; bitBtnCancel : TBitBtn ; bitBtnOK : TBitBtn ; directoryListBox : TDirectoryListBox ; driveComboBox : TDriveComboBox ; label1 : TLabel ; label2 : TLabel ; labelDir : TLabel ; begin formPickDir := TForm.create( self ) ; try with formPickDir do begin borderIcons := [biSystemMenu] ; borderStyle := bsDialog ; caption := 'Pick a directory' ; position := poScreenCenter ; font.name := 'Arial' ; font.size := 9 ; height := 273 ; width := 301 ; end ; labelDir := TLabel.create( formPickDir ) ; with labelDir do begin parent := formPickDir ; top := 24 ; left := 16 ; font.style := [fsBold] ; end ; directoryListBox := TDirectoryListBox.create( formPickDir ) ; with directoryListBox do begin parent := formPickDir ; top := 48 ; left := 16 ; width := 145 ; height := 129 ; directory := oEdit.text ; dirLabel := labelDir ; end ; driveComboBox := TDriveComboBox.create( formPickDir ) ; with driveComboBox do begin parent := formPickDir ; top := 208 ; left := 16 ; width := 145 ; height := 21 ; dirList := directoryListBox ; end ; bitBtnOK := TBitBtn.create( formPickDir ) ; with bitBtnOK do begin parent := formPickDir ; top := 48 ; left := 184 ; width := 81 ; height := 25 ; kind := bkOK ; modalResult := mrOK ; caption := '&OK' ; default := false ; end ; bitBtnCancel := TBitBtn.create( formPickDir ) ; with bitBtnCancel do begin parent := formPickDir ; top := 80 ; left := 184 ; width := 81 ; height := 25 ; kind := bkCancel ; modalResult := mrCancel ; caption := '&Cancel' ; default := false ; font.style := [fsBold] ; end ; label1 := TLabel.create( formPickDir ) ; with label1 do begin parent := formPickDir ; top := 8 ; left := 16 ; caption := 'Folders' ; font.style := [fsBold] ; end ; label2 := TLabel.create( formPickDir ) ; with label2 do begin parent := formPickDir ; top := 184 ; left := 16 ; caption := 'Drives' ; font.style := [fsBold] ; end ; directoryListBox.directory := oEdit.text ; if formPickDir.showModal = mrOK then begin self.text := directoryListBox.directory ; end ; finally formPickDir.free ; end ; end ; //------------------------------------------------------------------------------ procedure TtiPickDirectory.PickDirectoryOnExit( sender : TObject ) ; var sDirectory : string ; begin if not FbCreateDir then exit ; sDirectory := self.text ; if not DirectoryExists( sDirectory ) then begin if not messageDlg( 'Directory <' + sDirectory + '> does not exist.' + #13 + 'Do you want to create it ?', mtConfirmation, [mbYes, mbNo], 0 ) = mrYes then begin self.setFocus ; exit ; //==> end ; ForceDirectories( sDirectory ) ; if not DirectoryExists( sDirectory ) then begin raise exception.create( 'Can not create directory <' + sDirectory + '>' ) ; end ; end ; end ; //* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * //* //* TPickFile //* //* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} constructor TtiPickFile.create( owner : TComponent ) ; begin inherited create( owner ) ; FsDefaultExt := '' ; FsFilter := 'All files|*.*' ; FsTitle := '' ; end ; //------------------------------------------------------------------------------ procedure TtiPickFile.buttonClick( sender : TObject ) ; var oOpenDialog : TOpenDialog ; begin oOpenDialog := TOpenDialog.create( self ) ; try oOpenDialog.title := self.title ; oOpenDialog.Filter := self.filter ; oOpenDialog.defaultExt := self.defaultExt ; oOpenDialog.fileName := self.text ; if oOpenDialog.execute then begin self.text := oOpenDialog.fileName ; end ; finally oOpenDialog.free ; end ; end ; //* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * //* //* TAmuseUser //* //* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} //------------------------------------------------------------------------------ constructor TtiAmuseUser.create( oOwner : TComponent ) ; begin inherited create( oOwner ) ; oForm := TForm.create( self ) ; with oForm do begin height := 142 ; width := 301 ; borderIcons := [] ; borderStyle := bsDialog ; formStyle := fsStayOnTop ; position := poScreenCenter ; font.name := 'Arial' ; font.size := 9 ; caption := 'Long process in progress...' ; end ; oGauge := TGauge.create( self ) ; with oGauge do begin parent := oForm ; top := 56 ; left := 16 ; height := 25 ; width := 257 ; showText := false ; maxValue := 100 ; foreColor := clNavy ; end ; oLabel := TLabel.create( self ) ; with oLabel do begin parent := oForm ; top := 16 ; left := 24 ; width := 257 ; alignment := taCenter ; caption := 'Long process in progress...' ; end ; oTimer := TTimer.create( self ) ; with oTimer do begin onTimer := oTimerTimer ; interval := 25 ; end ; end ; //------------------------------------------------------------------------------ destructor TtiAmuseUser.free ; begin oForm.free ; oGauge.free ; oLabel.free ; oTimer.free ; inherited free ; end ; //------------------------------------------------------------------------------ function TtiAmuseUser.getCaption : string ; begin result := oForm.caption ; end ; //------------------------------------------------------------------------------ procedure TtiAmuseUser.setCaption( sValue : string ) ; begin oForm.caption := sValue ; self.messageLine := sValue ; end ; //------------------------------------------------------------------------------ function TtiAmuseUser.getMessageLine : string ; begin result := oLabel.caption ; oLabel.alignment := taCenter ; end ; //------------------------------------------------------------------------------ procedure TtiAmuseUser.setMessageLine( sValue : string ) ; begin oLabel.caption := sValue ; end ; //------------------------------------------------------------------------------ procedure TtiAmuseUser.setEnabled( bValue : boolean ) ; begin if bValue then begin oForm.show ; oTimer.enabled := true ; screen.cursor := crHourGlass ; end else begin oForm.hide ; oTimer.enabled := false ; screen.cursor := crDefault ; end ; application.processMessages ; end ; //------------------------------------------------------------------------------ function TtiAmuseUser.getEnabled : boolean ; begin result := oForm.visible ; end ; //------------------------------------------------------------------------------ procedure TtiAmuseUser.oTimerTimer( sender: TObject ) ; begin if oGauge.progress <> oGauge.maxValue then begin oGauge.progress := oGauge.progress + 1 ; end else begin oGauge.progress := 0 ; if oGauge.foreColor = clWhite then begin oGauge.foreColor := clNavy ; oGauge.backColor := clWhite ; end else begin oGauge.foreColor := clWhite ; oGauge.backColor := clNavy ; end ; end ; end; //* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * //* //* TtiHistoryComboBox //* //* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} constructor TtiHistoryComboBox.create( owner : TComponent ) ; begin inherited create( owner ) ; self.onExit := historyComboBoxExit ; FiHistoryCount := 5 ; end ; //------------------------------------------------------------------------------ destructor TtiHistoryComboBox.destroy ; begin oReg.free ; inherited destroy ; end ; //------------------------------------------------------------------------------ procedure TtiHistoryComboBox.loaded ; var i : integer ; sItem : string ; begin inherited loaded ; oReg := TRegINIFile.create( tiRemoveExtension( extractFileName( application.exeName ))) ; self.items.clear ; for i := 0 to FiHistoryCount-1 do begin sItem := oReg.readString( self.owner.name, self.name + intToStr( i+1 ), '' ) ; if sItem = '' then begin break ; //==> end ; self.items.add( sItem ) ; end ; self.text := oReg.readString( self.owner.name, self.name + '0', '' ) ; end; //------------------------------------------------------------------------------ procedure TtiHistoryComboBox.historyComboBoxExit( sender : TObject ) ; var i : integer ; begin try if assigned( onValidate ) then onValidate( self ) ; except on e:exception do begin self.setFocus ; messageDlg( e.message, mtError, [mbOK],0 ) ; raise ; end ; end ; if self.items.indexOf( self.text ) = -1 then begin self.items.insert( 0, self.text ) ; end ; while self.items.count > FiHistoryCount do begin self.items.delete( self.items.count-1 ) ; end ; for i := 0 to self.items.count - 1 do begin oReg.writeString( self.owner.name, self.name + intToStr( i+1 ), self.items[i] ) ; end ; oReg.writeString( self.owner.name, self.name + '0', self.text ) ; end ; //------------------------------------------------------------------------------ procedure TtiHistoryComboBox.SetHistoryCount(const iValue: integer); begin if iValue < 5 then begin FiHistoryCount := 5 ; exit ; end ; if iValue > 20 then begin FiHistoryCount := 20 ; exit ; end ; FiHistoryCount := iValue ; end; //* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * //* //* TDirectoryTree //* //* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * { constructor TDirectory.createExt(const pStrDirectory: string); begin inherited create ; Name := pStrDirectory ; end; //------------------------------------------------------------------------------ function TDirectory.TopOfPath : string; var i : integer ; lIntPos : integer ; begin lIntPos := -1 ; for i := length( Name ) downto 1 do begin if copy( Name, i, 1 ) = '\' then begin lIntPos := i + 1 ; break ; //==> end ; end ; if lIntPos <> -1 then result := copy( Name, lIntPos, length( Name ) - lIntPos + 1 ) else result := '' ; end; //------------------------------------------------------------------------------ function TDirectory.NameUpper : string; begin result := upperCase( Name ) ; end; //------------------------------------------------------------------------------ function TDirectory.DirToStringList( const pStrDirectory : string ) : TStringList ; var i : integer ; iPos : integer ; lStrDirPart : string ; lStrDirFull : string ; begin result := TStringList.create ; lStrDirFull := pStrDirectory ; for i := 1 to length( pStrDirectory ) do begin iPos := pos( '\', lStrDirFull ) ; if iPos <> 0 then begin lStrDirPart := copy( lStrDirFull, 1, iPos-1 ) ; lStrDirFull := copy( lStrDirFull, iPos+1, length( lStrDirFull ) + 1 ) ; result.Add( lStrDirPart ) ; end else begin result.Add( lStrDirFull ) ; break ; //==> end ; end ; end ; //------------------------------------------------------------------------------ function TDirectory.IsRootInDir(const pStrDirectory: string): boolean; var lslCurrentDir : TStringList ; lslCompDir : TStringList ; i : integer ; begin result := true ; lslCurrentDir := DirToStringList( NameUpper ) ; try lslCompDir := DirToStringList( upperCase( pStrDirectory )) ; try for i := 0 to min( lslCurrentDir.Count-1, lslCompDir.Count-1 ) do begin if lslCurrentDir.Strings[i] <> lslCompDir.Strings[i] then begin result := false ; break ; //==> end ; end ; finally lslCompDir.free ; end ; finally lslCurrentDir.free ; end ; end; } //* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * //* //* File wide funcs and procs //* //* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * //------------------------------------------------------------------------------ function tiNumToken( sString, sToken : string ) : integer ; var i, iCount : integer ; begin iCount := 0 ; i := pos( sToken, sString ) ; while i <> 0 do begin delete( sString, i, length( sToken )) ; inc( iCount ) ; i := pos( sToken, sString ) ; end ; result := iCount + 1 ; end ; //------------------------------------------------------------------------------ function tiToken( sString, sToken : string; iNum : integer ) : string ; var i, iCount, iNumToken : integer ; begin result := '' ; iNumToken := tiNumToken( sString, sToken ) ; if iNum = 1 then begin if pos( sToken, sString ) = 0 then result := sString else result := copy( sString, 1, pos( sToken, sString )-1) ; end else if (iNumToken < iNum-1) or (iNum<1) then begin result := '' ; end else begin // Remove leading blocks iCount := 1 ; i := pos( sToken, sString ) ; while (i<>0) and (iCount<iNum) do begin delete( sString, 1, i ) ; inc( iCount ) ; i := pos( sToken, sString ) ; end ; if (i=0) and (iCount=iNum) then result := sString else if (i=0) and (iCount<>iNum) then result := '' else result := copy( sString, 1, i-length( sToken )) ; end ; end ; //------------------------------------------------------------------------------ function tiStrTran( sStr, sDel, sIns : string ) : string ; var i : integer ; begin i := pos( sDel, sStr ) ; while i <> 0 do begin delete( sStr, i, length( sDel )) ; insert( sIns, sStr, i ) ; i := pos( sDel, sStr ) ; end ; result := sStr ; end ; //------------------------------------------------------------------------------ function tiRemoveExtension( sValue : string ) : string ; var i : integer ; begin i := pos( '.', sValue ) ; if i <> 0 then begin result := copy( sValue, 1, i - 1 ) ; end else begin result := sValue ; end ; end ; //* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * //* //* TnorFloatEdit ; //* //* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * //------------------------------------------------------------------------------ constructor TtiFloatEdit.create( owner : TComponent ) ; begin inherited create( owner ) ; self.precision := 3 ; end ; //* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * //* //* TnorCurrencyEdit ; //* //* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * //------------------------------------------------------------------------------ constructor TtiCurrencyEdit.create( owner : TComponent ) ; begin inherited create( owner ) ; self.TextBefore := '$ ' ; self.precision := 2 ; end ; //* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * //* //* TtiPercentEdit //* //* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * //------------------------------------------------------------------------------ constructor TtiPercentEdit.create( owner : TComponent ) ; begin inherited create( owner ) ; self.textAfter := ' %' ; self.precision := 0 ; end ; //* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * //* //* TnorIntegerEdit //* //* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * //------------------------------------------------------------------------------ constructor TtiIntegerEdit.create( owner : TComponent ) ; begin inherited create( owner ) ; end ; //------------------------------------------------------------------------------ function TtiIntegerEdit.getAsInteger : longInt ; var r : real ; begin // result := trunc( self.asFloat ) ; r := self.asFloat ; result := trunc( r ) + trunc( frac( r ) * 2 ) ; end ; //------------------------------------------------------------------------------ procedure TtiIntegerEdit.setAsInteger( iValue : longInt ) ; begin self.asFloat := iValue ; end ; //* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * //* //* TtiToolBar //* //* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * constructor TtiToolBar.create(owner: TComponent); begin inherited create( owner ) ; self.flat := true ; self.height := 25 ; end; //* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * //* //* TtiPickAlias //* //* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * procedure TtiPickAlias.ReadItems; begin Items.Clear ; Session.GetAliasNames( Items ) ; end; // * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * // * // * TtiDateRange // * // * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} {------------------------------------------------------------------------------} constructor TtiDateRange.create( oOwner : TComponent ) ; begin inherited create( oOwner ) ; self.width := 185 ; self.height := 113 ; self.caption := ' &Date range ' ; labelFrom := TLabel.create( self ) ; with labelFrom do begin parent := self ; top := 20 ; left := 8 ; caption := 'From' ; end ; labelTo := TLabel.create( self ) ; with labelTo do begin parent := self ; top := 44 ; left := 8 ; caption := 'To' ; end ; FDateTimePickerFrom := TDateTimePicker.Create( self ) ; with FDateTimePickerFrom do begin parent := self ; top := 16 ; left := 40 ; height := 22 ; width := 130 ; OnChange := OnChangeEvent ; end ; FDateTimePickerTo := TDateTimePicker.Create( self ) ; with FDateTimePickerTo do begin parent := self ; top := 40 ; left := 40 ; height := 22 ; width := 130 ; OnChange := OnChangeEvent ; end ; radioButtonDatesAll := TRadioButton.create( self ) ; with radioButtonDatesAll do begin parent := self ; top := 70 ; left := 8 ; height := 17 ; width := 33 ; caption := 'All' ; onClick := radioButtonDatesClick ; end ; radioButtonDatesMonth := TRadioButton.create( self ) ; with radioButtonDatesMonth do begin parent := self ; height := 17 ; left := 8 ; top := 88 ; width := 53 ; caption := 'Month' ; onClick := radioButtonDatesClick ; end ; radioButtonDatesWeek := TRadioButton.create( self ) ; with radioButtonDatesWeek do begin parent := self ; height := 17 ; left := 64 ; top := 70 ; width := 52 ; caption := 'Week' ; onClick := radioButtonDatesClick ; end ; radioButtonDatesToday := TRadioButton.create( self ) ; with radioButtonDatesToday do begin parent := self ; height := 17 ; left := 64 ; top := 88 ; width := 53 ; caption := 'Today' ; onClick := radioButtonDatesClick ; end ; radioButtonDatesCustom := TRadioButton.create( self ) ; with radioButtonDatesCustom do begin parent := self ; height := 17 ; left := 120 ; top := 70 ; width := 61 ; caption := 'Custom' ; onClick := radioButtonDatesClick ; end ; end ; //------------------------------------------------------------------------------ procedure TtiDateRange.Loaded ; begin inherited ; DateFrom := date ; DateTo := date ; dateAllEarliest := encodeDate( 1, 1, 1 ) ; dateAllLatest := encodeDate( 9999, 12, 31 ) ; radioButtonDatesCustom.Checked := true ; end ; {------------------------------------------------------------------------------} procedure TtiDateRange.RadioButtonDatesClick(Sender: TObject); var i : integer ; wYear : word ; wMonth : word ; wDay : word ; begin { Set the date maskEdit and speedButton enabled property as necessary. } FDateTimePickerFrom.enabled := radioButtonDatesCustom.checked ; FDateTimePickerTo.enabled := radioButtonDatesCustom.checked ; decodeDate( date, wYear, wMonth, wDay ) ; for i := 0 to self.componentCount - 1 do begin if (self.components[i] is TRadioButton) then begin if TRadioButton(self.components[i]) <> TRadioButton( sender ) then begin TRadioButton( sender ).checked := true ; end ; end ; end ; if radioButtonDatesAll.checked then begin FDateTimePickerFrom.Date := dateAllEarliest ; FDateTimePickerTo.Date := dateAllLatest ; FDateGroup := dgAll ; Exit ; end ; // Bug in set month after year was clicked. if radioButtonDatesMonth.checked then begin FDateTimePickerFrom.Date := encodeDate( wYear, wMonth, 1 ) ; if wMonth = 12 then begin wMonth := 1 ; inc( wYear ) ; end else begin inc( wMonth ) ; end ; FDateTimePickerTo.Date := encodeDate( wYear, wMonth, 1 ) - 1 ; FDateGroup := dgMonth ; Exit ; end ; if radioButtonDatesWeek.checked then begin FDateTimePickerFrom.Date := date - dayOfWeek( date ) + 1 ; FDateTimePickerTo.Date := date - dayOfWeek( date ) + 7 ; FDateGroup := dgWeek ; Exit ; end ; if radioButtonDatesToday.checked then begin FDateTimePickerFrom.Date := date ; FDateTimePickerTo.Date := date ; FDateGroup := dgToday ; Exit ; end ; { User entered date, do nothing } if radioButtonDatesCustom.checked then begin FDateGroup := dgCustom ; end ; OnChangeEvent( sender ) ; end; {------------------------------------------------------------------------------} function TtiDateRange.getDateFrom : TDateTime ; begin result := trunc( FDateTimePickerFrom.Date ) ; end ; {------------------------------------------------------------------------------} procedure TtiDateRange.putDateFrom( const dDate : TDateTime ) ; begin FDateTimePickerFrom.Date := trunc( dDate ) ; end ; {------------------------------------------------------------------------------} function TtiDateRange.getDateTo : TDateTime ; begin result := trunc( FDateTimePickerTo.Date ) ; end ; {------------------------------------------------------------------------------} procedure TtiDateRange.putDateTo( const dDate : TDateTime ) ; begin FDateTimePickerTo.Date := trunc( dDate ) ; end ; {------------------------------------------------------------------------------} { function TtiDateRange.getDateToAsString : string ; begin result := tiDateTimeToStr( DateTo ) ; end ; } {------------------------------------------------------------------------------} { procedure TtiDateRange.putDateToAsString( sDate : string ) ; var dTemp : TDateTime ; begin try dTemp := strToDateTime( sDate ) ; FDateTimePickerTo.Date := dTemp ; except messageDlg( sDate + ' is not a valid date', mtError, [mbOK], 0 ) ; FDateTimePickerTo.Date := date ; end ; end ; } {------------------------------------------------------------------------------} { function TtiDateRange.getDateFromAsString : string ; begin Result := tiDateTimeToStr( FDateTimePickerFrom.Date ) ; end ; } {------------------------------------------------------------------------------} { procedure TtiDateRange.putDateFromAsString( sDate : string ) ; var dTemp : TDateTime ; begin try dTemp := strToDateTime( sDate ) ; FDateTimePickerFrom.Date := dTemp ; except messageDlg( sDate + ' is not a valid date', mtError, [mbOK], 0 ) ; FDateTimePickerFrom.Date := date ; end ; end ; } {------------------------------------------------------------------------------} procedure TtiDateRange.setDateGroup( const dgDateGroup : TDateGroup ) ; var radioButtonTemp : TRadioButton ; begin FDateGroup := dgDateGroup ; case dgDateGroup of dgAll : radioButtonTemp := radioButtonDatesAll ; dgWeek : radioButtonTemp := radioButtonDatesWeek ; dgMonth : radioButtonTemp := radioButtonDatesMonth ; dgToday : radioButtonTemp := radioButtonDatesToday ; dgCustom : radioButtonTemp := radioButtonDatesCustom ; else radioButtonTemp := radioButtonDatesAll end ; with RadioButtonTemp do begin if showing then setFocus ; checked := true ; end ; end ; {------------------------------------------------------------------------------} function TtiDateRange.getDateGroup : TDateGroup ; begin result := FDateGroup ; end ; {------------------------------------------------------------------------------} { function TtiDateRange.geTtiDateRangeAsText : string ; begin case self.DateGroup of dgAll : result := 'All dates' ; dgToday : result := 'Date: ' + self.dateFromAsString ; else result := 'From: ' + self.dateFromAsString + ' to ' + self.dateToAsString ; end ; end ; } procedure TtiDateRange.OnChangeEvent(sender: TObject); begin if not( sender is TRadioButton ) and ( FDateGroup <> dgCustom ) then exit ; if assigned( FOnChange ) then FOnChange( Sender ) ; end; procedure TBaseFloatEdit.BaseFloatEditClick( sender : TObject ) ; begin SelectAll ; end; { TtiPanel } constructor TtiPanel.Create(owner: TComponent); begin inherited Create( owner ) ; ControlStyle := ControlStyle - [csSetCaption] ; BevelInner := bvNone ; BevelOuter := bvNone ; BorderStyle := bsNone ; end; // * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * // * // * TtiClock // * // * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * constructor TtiClock.Create(owner: TComponent); begin inherited Create( owner ) ; Parent := owner as TWinControl ; FTimer := TTimer.Create( self ) ; FLabel := TLabel.Create( self ) ; FLabel.parent := self ; FLabel.Top := 2 ; FLabel.Left := 2 ; FTimer.OnTimer := OnTimer ; FTimer.Enabled := false ; TimeFormat := 'hh:mm:ss' ; FLabel.Caption := TimeFormat ; Offset := 0 ; end ; //------------------------------------------------------------------------------ function TtiClock.GetEnabled: boolean; begin result := FTimer.Enabled ; end; { ToDo 5 -cFramework: Make the TtiClock an observer so all instances of the clock share the same, global TTimer object. } //------------------------------------------------------------------------------ procedure TtiClock.OnTimer( sender : TObject ) ; begin try FLabel.Caption := FormatDateTime( TimeFormat, Now + ( Offset * cdtOneSecond )) ; except on e:exception do begin Enabled := false ; MessageDlg( 'Error showing time. Message: ' + e.message , mtError, [mbOK], 0 ) ; end ; end ; end ; //------------------------------------------------------------------------------ procedure TtiClock.SetEnabled(Value: boolean); begin FTimer.Enabled := Value ; if Enabled then OnTimer( nil ) ; end; //------------------------------------------------------------------------------ procedure TtiClock.SetTimeFormat(const Value: string); begin FsTimeFormat := Value; ClientHeight := Canvas.TextHeight( FsTimeFormat ) + 4 ; ClientWidth := Canvas.TextWidth( FsTimeFormat ) + 4 ; end; // * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * // * // * TtiButtonPanel // * // * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * { ToDo 5 -cComponents: TtiButtonPanel: Add variable number of buttons, with var captions and glyphs } constructor TtiButtonPanel.Create(owner: TComponent); begin inherited Create( owner ) ; Width := 253 ; Height := 31 ; Align := alBottom ; BevelOuter := bvNone ; ControlStyle := ControlStyle - [csSetCaption] ; FBtn1 := TBitBtn.Create( nil ) ; with FBtn1 do begin Parent := self ; Left := 94 ; Top := 4 ; Width := 75 ; Height := 25 ; Anchors := [akRight, akBottom] ; TabOrder := 0 ; OnClick := DoBtn1Click ; Kind := bkOK ; ModalResult := mrOK ; end ; FBtn2 := TBitBtn.Create( nil ) ; with FBtn2 do begin Parent := self ; Left := 174 ; Top := 4 ; Width := 75 ; Height := 25 ; Anchors := [akRight, akBottom] ; TabOrder := 1 ; OnClick := DoBtn2Click ; Kind := bkCancel ; ModalResult := mrCancel ; end ; end ; destructor TtiButtonPanel.Destroy; begin FBtn1.Free ; FBtn2.Free ; inherited; end; procedure TtiButtonPanel.DoBtn1Click(sender: TObject); begin if Assigned( FOnBtn1Click ) then FOnBtn1Click( self ) ; end; procedure TtiButtonPanel.DoBtn2Click(sender: TObject); begin if Assigned( FOnBtn2Click ) then FOnBtn2Click( self ) ; end; procedure TtiButtonPanel.SetOnBtn1Click(const Value: TNotifyEvent); begin FOnBtn1Click := Value; if Assigned( FOnBtn1Click ) then FBtn1.ModalResult := mrNone else FBtn1.ModalResult := mrOK ; end; procedure TtiButtonPanel.SetOnBtn2Click(const Value: TNotifyEvent); begin FOnBtn2Click := Value; if Assigned( FOnBtn2Click ) then FBtn2.ModalResult := mrNone else FBtn2.ModalResult := mrCancel ; end; { TtiMessageDlg } procedure TtiMessageDlg.Clear; var i : integer ; begin for i := 0 to FBtns.Count - 1 do TObject( FBtns.Items[i] ).Free ; end; constructor TtiMessageDlg.Create(owner: TComponent); begin inherited Create( Owner ) ; FForm := TForm.Create( Nil ) ; FForm.Position := poScreenCenter ; FForm.Width := 320 ; FForm.Height := 250 ; FForm.BorderStyle := bsDialog ; FForm.BorderIcons := [] ; FForm.Visible := false ; FMemo := TMemo.Create( FForm ) ; FMemo.Parent := FForm ; FMemo.Top := 4 ; FMemo.Left := 4 ; FMemo.Width := 200 ; FMemo.Height := 150 ; FMemo.WordWrap := true ; FMemo.ScrollBars := ssNone ; FMemo.ReadOnly := true ; FMemo.TabStop := false ; FMemo.Color := clBtnFace ; FMemo.BorderStyle := bsNone ; FBtns := TList.Create ; FsResult := '' ; end; destructor TtiMessageDlg.Destroy; begin Clear ; FForm.Free ; FBtns.Free ; inherited; end; procedure TtiMessageDlg.DoOnClick(sender: TObject); begin FsResult := TButton( Sender ).Caption ; FForm.ModalResult := mrOK ; end; function TtiMessageDlg.Execute( const psMessage: string; paOptions: array of string; psCaption : string ): string; var lBtn : TButton ; i : integer ; begin Clear ; FMemo.Lines.Text := psMessage ; for i := Low( paOptions ) to High ( paOptions ) do begin lBtn := TButton.Create( nil ) ; lBtn.Parent := FForm ; lBtn.Top := FMemo.Top + FMemo.Height + 4 ; lBtn.Left := 4 + ( lBtn.Width + 4 ) * i ; lBtn.Caption := paOptions[i] ; lBtn.OnClick := DoOnClick ; FBtns.Add( lBtn ) ; end ; FForm.Caption := psCaption ; FForm.ShowModal ; Result := FsResult ; end; end.